  subroutine mopy2mo_bbbb_sym_s(icore, itmp, nmo, l, irrepl, isymmo, & 
                   isympopa, isympopb, isymvrta, isymvrtb, nomax, nvmax)   
  use mod_orbit
  use mod_symm
  use mod_iop
  implicit none 
  integer, intent(in) :: nmo, l, irrepl, nvmax, nomax
  integer, intent(in) :: isympopa(nomax, 8), isympopb(nomax, 8)
  integer, intent(in) :: isymvrta(nvmax, 8), isymvrtb(nvmax, 8), isymmo(nmo, 8, 2)
  real*4, intent(in) :: icore(nmo, nmo, nmo)
  real*4, intent(out) :: itmp(*)

  integer i, j, k, a, b, c, d, numka, ioffka 
  integer idx, idxi, idxj, idxk,idxold, idxa, idxb, idxc
  integer noa2, nob2, noab, nva2, nvb2, nvab
  integer nvoa, nvob, nvaob, nvboa, isymabc
  integer nvvabsym(8), nvoabsym(8)
  integer nvobasym(8), nooabsym(8)
  integer nvoaasym(8), nvobbsym(8)
  integer nooaasym(8), nvvaasym(8)
  integer noobbsym(8), nvvbbsym(8)
  integer nvv1(8), nvv2(8)
  integer nfirst, nread, nsize, isymoffk(8)
  integer irrep, isym, irrepi, irrepj, irrepij, irrepk
  integer irrepab, irrepa, irrepb, irrepbi, irrepc, irrepaj
  integer irrepci, irrepka, irrepd
  integer ioffij, ioffk, ioffi, ioffab, ioffa, ioffbi
  integer ioffj, ioffc, ioffd, ioffab1, ioffab2
  integer numi, numj, numk, numij, numab, numa, numb
  integer numbi, numc, numab1, numab2, ioffc1, ioffc2
  integer,external :: irpdso, idsymsoc, isymoffso
  real*8, external :: nrm2so, dnrm2
   isym = dirprd(irrepl, 1) 
!  write(6,*)'nirrep', nirrep,l, irrepl
  do irrep = 1, nirrep
     nvvabsym(irrep) = irpdso(irrep, vrta, vrtb, 1)
     nvoabsym(irrep) = irpdso(irrep, vrta, popb, 1)
     nvobasym(irrep) = irpdso(irrep, vrtb, popa, 1)
     nvoaasym(irrep) = irpdso(irrep, vrta, popa, 1)
     nvobbsym(irrep) = irpdso(irrep, vrtb, popb, 1)
     nooabsym(irrep) = irpdso(irrep, popa, popb, 1)
     nooaasym(irrep) = irpdso(irrep, popa, popa, 0)
     nvvaasym(irrep) = irpdso(irrep, vrta, vrta, 0)
     noobbsym(irrep) = irpdso(irrep, popb, popb, 0)
     nvvbbsym(irrep) = irpdso(irrep, vrtb, vrtb, 0)
     nvv1(irrep) = irpdso(irrep, vrta, vrta, 0)
     nvv2(irrep) = irpdso(irrep, vrta, vrta, 2)
  enddo
  !BBBB
    !IJKL_BBBB  (IK|JL)-(JK|IL)
    idx = 0
    if(l<=popa(irrepl)) then 
!      write(6,*)'l', l, irrepl, isymmo(l, irrepl, 1)
!     do irrepk = 1, nirrep 
!        write(6,'(A,8I4)') 'test',irrepk, isympopa(:,irrepk)
!     enddo
      do irrepk  = 1, nirrep 
         irrepij = dirprd(irrepk, isym) 
         numk = popb(irrepk)
         ioffk = isymoffso(irrepk, isym, noobbsym, popb, 1)
         numij = irpdso(irrepij, popb, popb, 0)
         do k = 1, numk 
         do irrepj = 1, nirrep
!            write(6,*)'test in mopy2mo'
            irrepi = dirprd(irrepj, irrepij) 
            numj = popb(irrepj) 
            numi = popb(irrepi)
            ioffij = isymoffso(irrepj, irrepij, popb, popb, 0)
            if(irrepi>irrepj) cycle 
            if(irrepi<irrepj) then 
               do j = 1, numj 
               do i = 1, numi
                  idxi = isympopb(i, irrepi) 
                  idxj = isympopb(j, irrepj) 
                  idxk = isympopb(k, irrepk) 
                  !<Ij||Kl>=(IK|jk)
                  idx = (ioffk-1)+ (k-1)*numij + ioffij-1 + (j-1)*numi + i    
                  itmp(idx) = icore(idxi,idxk,idxj) - icore(idxj, idxk, idxi) 
!                  write(6,'(A,3I6, F18.12)')'icore', idxi, idxj, idxk, icore(idxi, idxk, idxj)
               enddo
               enddo
            elseif(irrepi==irrepj) then
               do j = 2, numj
               do i = 1, j-1 
                  idxi = isympopb(i, irrepi)
                  idxj = isympopb(j, irrepj)
                  idxk = isympopb(k, irrepk)
                  !<Ij||Kl>=(IK|jk)
                  idx = (ioffk-1)+ (k-1)*numij + ioffij-1 + (j-1)*(j-2)/2 + i
                  itmp(idx) = icore(idxi,idxk,idxj) - icore(idxj, idxk, idxi)
!                  write(6,'(A,3I6, F18.12)')'icore', idxi, idxj, idxk, icore(idxi, idxk, idxj)
               enddo
               enddo
            endif 
!            write(6,*)'test in mopy2mo'
         enddo
         enddo
      enddo
!       nsize = irpdso(isym, noobbsym, popb, 1) 
!       nsize = idsymsoc(isym, popb, popb, 0, popb, zorb, 1)
!       write(6,'(A, I8, I8, I8,F18.8)')'norm of ijkl',  isymmo(l, irrepl,2), l,irrepl, nrm2so(nsize, itmp, 1) 
      call putpqrso_s(itmp, l, irrepl, 1,  'IJKLBBS_')
    endif
!    stop
!    write(6,*)'finished IJKLAB' 
    !ABIJ_AAAA
    if(l<=popb(irrepl)) then
      j = l 
      irrepj = irrepl 
      do irrepi = 1, nirrep
         irrepab = dirprd(irrepi, isym) 
         numi = popb(irrepi) 
         numab = irpdso(irrepab, vrtb, vrtb, 0)
         ioffi = isymoffso(irrepi, isym, nvvbbsym, popb, 1) 
         do irrepb = 1, nirrep
            irrepa = dirprd(irrepb, irrepab)
            numb = vrtb(irrepb) 
            numa = vrtb(irrepa)
            ioffab = isymoffso(irrepb, irrepab, vrtb, vrtb, 0)
            if(irrepa>irrepb) cycle 
            if(irrepa<irrepb) then 
               do i = 1, numi
               do b = 1, numb 
               do a = 1, numa
                  idxi = isympopb(i, irrepi) 
                  idxa = isymvrtb(a, irrepa) 
                  idxb = isymvrtb(b, irrepb) 
                  idx = (ioffi-1) + (i-1)*numab + ioffab-1 + (b-1)*numa + a
                  itmp(idx) = icore(idxa, idxi, idxb)-icore(idxb,idxi,idxa)
               enddo
               enddo
               enddo
            elseif(irrepa==irrepb) then 
               do i = 1, numi
               do b = 2, numb 
               do a = 1,b-1 
                  idxi = isympopb(i, irrepi) 
                  idxa = isymvrtb(a, irrepa) 
                  idxb = isymvrtb(b, irrepb) 
                  idx = (ioffi-1) + (i-1)*numab + ioffab-1 + (b-1)*(b-2)/2 + a
                  itmp(idx) = icore(idxa, idxi, idxb)-icore(idxb,idxi,idxa)
               enddo
               enddo
               enddo
            endif
          enddo
       enddo
!       write(6,*)'l,irrepl', l, irrepl
       nsize = irpdso(isym, nvvbbsym, popb, 1) 
!       write(6,'(A, I5, I5, I5, F18.8)')'norm of abij',  isymmo(l, irrepl,1), l, irrepl, nrm2so(nsize, itmp, 1) 
       call putpqrso_s(itmp, l, irrepl, 1,  'ABIJBBS_')
    endif
!    write(6,*)'finished ABIJAB' 
!   IABJ_BBBB = BIAJ
! <IA||BJ>=(IB|AJ)-(AB|IJ)
    if(l<=popb(irrepl)) then 
       j = l; irrepj = irrepl 
      do irrepa = 1, nirrep
         irrepbi = dirprd(irrepa, isym) 
         numa = vrtb(irrepa) 
         numbi = irpdso(irrepbi, vrtb, popb, 1) 
         ioffa = isymoffso(irrepa, isym, nvobbsym, vrtb, 1)
         do irrepi = 1, nirrep 
            irrepb = dirprd(irrepi, irrepbi) 
            numi = popb(irrepi) 
            numb = vrtb(irrepb) 
            ioffbi = isymoffso(irrepi, irrepbi, vrtb, popb, 1)
            do a = 1, numa
            do i = 1, numi
            do b = 1, numb
               idxa = isymvrtb(a, irrepa)
               idxi = isympopb(i, irrepi)
               idxb = isymvrtb(b, irrepb)
               idx = (ioffa-1) + (a-1)*numbi + ioffbi - 1 +(i-1)*numb+b
               itmp(idx) = icore(idxi, idxb, idxa) - icore(idxa, idxb, idxi)
            enddo
            enddo
            enddo
          enddo
        enddo
       call putpqrso_s(itmp, l, irrepl, 1,  'BIAJBBBS')
      endif
!    write(6,*)'finished BIAJ1'

!   !KAIJ_BBBB = (KI|AJ)-(KJ|AI)=(KI|AJ)-(AI|KJ)
    if(l<=popb(irrepl)) then
      j = l
      irrepj = irrepl
      do irrepi = 1, nirrep
         irrepka = dirprd(irrepi, isym)
         numi = popb(irrepi)
         numka = irpdso(irrepka, popb, vrtb, 1)
         ioffi = isymoffso(irrepi, isym, nvobbsym, popb, 1)
         do irrepa = 1, nirrep
            irrepk = dirprd(irrepa, irrepka)
            numa = vrtb(irrepa)
            numk = popb(irrepk)
            ioffka = isymoffso(irrepa, irrepka, popb, vrtb, 1)
            do i = 1, numi
            do a = 1, numa
            do k = 1, numk
               idxi = isympopb(i, irrepi)
               idxa = isymvrtb(a, irrepa)
               idxk = isympopb(k, irrepk)
               idx = (ioffi-1) + (i-1)*numka + ioffka-1 + (a-1)*numk + k
               itmp(idx) = icore(idxk, idxi, idxa)-icore(idxa,idxi,idxk)
            enddo
            enddo
            enddo
          enddo
       enddo
!       write(6,*)'l,irrepl', l, irrepl
       nsize = irpdso(isym, nvobbsym, popb, 1) 
!       write(6,'(A, I5, I5, I5, F18.8)')'norm of kaij',  isymmo(l, irrepl,1), l, irrepl, nrm2so(nsize, itmp, 1) 
        call putpqrso_s(itmp, l, irrepl, 1,  'KAIJBBS_')
    endif

    if(eri_level==0.or.eri_level==1) then 
!   !ABCI_AAAA = (AC|BI)-(BC|AI)
      if(l<=popb(irrepl)) then 
      do irrepc = 1, nirrep
         irrepab = dirprd(irrepc, isym) 
         numc = vrtb(irrepc) 
         numab = irpdso(irrepab, vrtb, vrtb, 0) 
         ioffc = isymoffso(irrepc, isym, nvvbbsym, vrtb, 1) 
         do irrepb = 1, nirrep
            irrepa = dirprd(irrepb, irrepab) 
            ioffab = isymoffso(irrepb, irrepab, vrtb, vrtb, 0) 
            numa = vrtb(irrepa)
            numb = vrtb(irrepb)
            if(irrepa>irrepb) cycle
            if(irrepa<irrepb) then  
              do c = 1, numc
              do b = 1, numb
              do a = 1, numa   
                 idxc = isymvrtb(c, irrepc) 
                 idxb = isymvrtb(b, irrepb) 
                 idxa = isymvrtb(a, irrepa) 
                 idx = ioffc - 1 + (c-1)*numab + ioffab - 1 + (b-1)*numa + a 
                 itmp(idx) = icore(idxa, idxc, idxb)-icore(idxb, idxc, idxa) 
              enddo
              enddo
              enddo
            elseif(irrepa==irrepb) then  
              do c = 1, numc
              do b = 2, numb
              do a = 1, b-1   
                 idxc = isymvrtb(c, irrepc) 
                 idxb = isymvrtb(b, irrepb) 
                 idxa = isymvrtb(a, irrepa) 
                 idx = ioffc - 1 + (c-1)*numab + ioffab - 1 + (b-1)*(b-2)/2 + a 
                 itmp(idx) = icore(idxa, idxc, idxb)-icore(idxb, idxc, idxa) 
              enddo
              enddo
              enddo
             endif
           enddo
        enddo
        call putpqrso_s(itmp, l, irrepl, 1,  'ABCIBBS_')
       endif 
     endif
!    write(6,*)'finished ABCI'

    if(eri_level==0) then
       if(l>popb(irrepl)) then
       d = l - popb(irrepl)
       irrepd = irrepl
       do irrepc = 1, nirrep
          irrepab = dirprd(irrepc, isym)
          numc = vrtb(irrepc)
          numab = irpdso(irrepab, vrtb, vrtb, 0)
          do irrepb = 1, nirrep
             irrepa = dirprd(irrepb, irrepab)
             ioffc = isymoffso(irrepc, isym, nvvbbsym, vrtb, 1)
             ioffab = isymoffso(irrepb, irrepab, vrtb, vrtb, 0)
             numa = vrtb(irrepa)
             numb = vrtb(irrepb)
             if(irrepa>irrepb) cycle 
             if(irrepa==irrepb) then 
               do c = 1, numc
               do b = 2, numb
               do a = 1, b-1
                  idxc = isymvrtb(c, irrepc)
                  idxb = isymvrtb(b, irrepb)
                  idxa = isymvrtb(a, irrepa)
                  idx = ioffc - 1 + (c-1)*numab + ioffab - 1 + (b-1)*(b-2)/2 + a
                  itmp(idx) = icore(idxa, idxc, idxb) - icore(idxb, idxc, idxa)
                enddo
                enddo
                enddo
             elseif(irrepa<irrepb) then 
               do c = 1, numc
               do b = 1, numb
               do a = 1, numa 
                  idxc = isymvrtb(c, irrepc)
                  idxb = isymvrtb(b, irrepb)
                  idxa = isymvrtb(a, irrepa)
                  idx = ioffc - 1 + (c-1)*numab + ioffab - 1 + (b-1)*numa + a
                  itmp(idx) = icore(idxa, idxc, idxb) - icore(idxb, idxc, idxa)
                enddo
                enddo
                enddo
              endif
            enddo
         enddo
         call putpqrso_s(itmp, d, irrepd, 1,  'ABCDBBS_')
        endif
!!!!    write(6,*)'finished abcdaa'
   endif

  return
  end
    
  
